home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 3 / Info_Mac_1994-01.iso / Development / Source / Morpion 1.0.0 Source / Game.p < prev    next >
Text File  |  1993-12-03  |  11KB  |  519 lines
  1. unit Game;
  2.  
  3. interface
  4.  
  5.     procedure InitGame;
  6.     procedure FinishGame;
  7.  
  8. implementation
  9.  
  10.     uses
  11.         MyOOMainLoop, MyDialogs, MyFMenus, MyUtils, MyMathUtils, MySpeak;
  12.  
  13.     const
  14.         max_row = 20;
  15.         max_col = 20;
  16.         cross = 4;
  17.         len = 5;
  18.  
  19.     type
  20.         rows = 1..max_row;
  21.         cols = 1..max_col;
  22.  
  23.     var
  24.         dr, dc: array[0..7] of integer;
  25.  
  26.     type
  27.         GameObject = object(DObject)
  28.                 finished, auto, show: boolean;
  29.                 vertex: array[rows, cols] of boolean;
  30.                 edges: array[rows, cols] of byte;
  31.                 score, moves: integer;
  32.                 mover, movec, moved: integer;
  33.                 diff: integer;
  34.                 procedure Create (id: integer);
  35.                 override;
  36.                 procedure Resize;
  37.                 override;
  38.                 procedure DrawBoard;
  39.                 function InRange (r, c: integer): boolean;
  40.                 function PointToCell (pt: Point; var r, c: integer): boolean;
  41.                 procedure CellToPoint (r, c: integer; var pt: Point);
  42.                 procedure DrawVertex (r, c: integer);
  43.                 function ValidLine (r, c, d: integer): boolean;
  44.                 procedure ShowMoves;
  45.                 procedure DLine (start: Point; dir: integer);
  46.                 procedure DoLine (r, c, d: integer);
  47.                 procedure DoMove (pt: Point);
  48.                 procedure DoItemWhere (er: eventRecord; item: integer);
  49.                 override;
  50.             end;
  51.  
  52.     procedure GameObject.Resize;
  53.         var
  54.             r: rect;
  55.     begin
  56.         r.left := 0;
  57.         r.right := window^.portrect.right - 16;
  58.         r.top := 0;
  59.         r.bottom := window^.portrect.bottom - 16;
  60.         SetDItemRect(window, 1, r);
  61.         diff := (Min(r.bottom, r.right) - 4) div (Max(max_row, max_col));
  62.         SetPort(window);
  63.         InsetRect(r, -100, -100);
  64.         InvalRect(r);
  65.     end;
  66.  
  67.     function GameObject.InRange (r, c: integer): boolean;
  68.     begin
  69.         InRange := (0 < r) & (r <= max_row) & (0 < c) & (c <= max_col);
  70.     end;
  71.  
  72.     function GameObject.PointToCell (pt: Point; var r, c: integer): boolean;
  73.     begin
  74.         r := (pt.v + diff div 2) div diff;
  75.         c := (pt.h + diff div 2) div diff;
  76.         PointToCell := InRange(r, c);
  77.     end;
  78.  
  79.     procedure GameObject.CellToPoint (r, c: integer; var pt: Point);
  80.     begin
  81.         pt.h := c * diff;
  82.         pt.v := r * diff;
  83.     end;
  84.  
  85.     procedure GameObject.Create (id: integer);
  86.         var
  87.             r, c, i, size: integer;
  88.     begin
  89.         inherited Create(id);
  90.         draw_grow_icon := true;
  91.         finished := false;
  92.         score := 0;
  93.         for r := 1 to max_row do begin
  94.             for c := 1 to max_col do begin
  95.                 vertex[r, c] := false;
  96.                 edges[r, c] := 0;
  97.             end;
  98.         end;
  99.         size := 3 * cross - 2;
  100.         r := (max_row - size) div 2 + 1;
  101.         c := (max_row - size) div 2 + 1;
  102.         for i := 0 to cross - 1 do begin
  103.             vertex[r, c + cross - 1 + i] := true;
  104.             vertex[r + size - 1, c + cross - 1 + i] := true;
  105.             vertex[r + cross - 1 + i, c] := true;
  106.             vertex[r + cross - 1 + i, c + size - 1] := true;
  107.             vertex[r + cross - 1, c + i] := true;
  108.             vertex[r + 2 * cross - 2, c + i] := true;
  109.             vertex[r + cross - 1, c + size - 1 - i] := true;
  110.             vertex[r + 2 * cross - 2, c + size - 1 - i] := true;
  111.             vertex[r + i, c + cross - 1] := true;
  112.             vertex[r + i, c + 2 * cross - 2] := true;
  113.             vertex[r + size - 1 - i, c + cross - 1] := true;
  114.             vertex[r + size - 1 - i, c + 2 * cross - 2] := true;
  115.         end;
  116.         Resize;
  117.         DrawBoard;
  118.     end;
  119.  
  120.     procedure GameObject.DrawVertex (r, c: integer);
  121.         const
  122.             d = 2;
  123.         var
  124.             i: integer;
  125.             mid: Point;
  126.     begin
  127.         CellToPoint(r, c, mid);
  128.         MoveTo(mid.h, mid.v);
  129.         if not vertex[r, c] then begin
  130.             Line(0, 0);
  131.         end
  132.         else begin
  133.             Move(-d, -d);
  134.             Line(d * 2, d * 2);
  135.             Move(-2 * d, 0);
  136.             Line(d * 2, -d * 2);
  137.             Move(0, d);
  138.             Line(-2 * d, 0);
  139.             Move(d, -d);
  140.             Line(0, 2 * d);
  141.         end;
  142.         for i := 0 to 7 do begin
  143.             if BTST(edges[r, c], i) then begin
  144.                 MoveTo(mid.h, mid.v);
  145.                 Line(diff * dc[i], diff * dr[i]);
  146.             end;
  147.         end;
  148.     end;
  149.  
  150.     procedure GameObject.DrawBoard;
  151.         var
  152.             r, c, d, count: integer;
  153.             box: rect;
  154.             mid: Point;
  155.     begin
  156.         SetPort(window);
  157.         GetDItemRect(window, 1, box);
  158.         EraseRect(box);
  159.         DrawGrowIcon(window);
  160.         for r := 1 to max_row do begin
  161.             for c := 1 to max_col do begin
  162.                 DrawVertex(r, c);
  163.             end;
  164.         end;
  165.         ShowMoves;
  166.     end;
  167.  
  168.     function GameObject.ValidLine (r, c, d: integer): boolean;
  169.         var
  170.             good: boolean;
  171.             i, cnt: integer;
  172.     begin
  173.         good := InRange(r, c);
  174.         cnt := 0;
  175.         i := 0;
  176.         while good and (i <= len - 2) do begin
  177.             cnt := cnt + ord(vertex[r, c]);
  178.             if BTST(edges[r, c], d) then begin
  179.                 good := false;
  180.             end;
  181.             r := r + dr[d];
  182.             c := c + dc[d];
  183.             good := good & InRange(r, c);
  184.             i := i + 1;
  185.         end;
  186.         if good then begin
  187.             cnt := cnt + ord(vertex[r, c]);
  188.         end;
  189.         ValidLine := good and (cnt >= 4);
  190.     end;
  191.  
  192.     procedure GameObject.DoLine (r, c, d: integer);
  193.         procedure DoSet (var b: byte; bit: integer);
  194.             var
  195.                 n: longInt;
  196.         begin
  197.             n := b;
  198.             BSET(n, bit);
  199.             b := n;
  200.         end;
  201.         var
  202.             i: integer;
  203.     begin
  204.         if ValidLine(r, c, d) then begin
  205.             for i := 0 to len - 2 do begin
  206.                 vertex[r, c] := true;
  207.                 DoSet(edges[r, c], d);
  208.                 DoSet(edges[r + dr[d], c + dc[d]], BAND(d + 4, 7));
  209.                 DrawVertex(r, c);
  210.                 r := r + dr[d];
  211.                 c := c + dc[d];
  212.             end;
  213.             vertex[r, c] := true;
  214.             DrawVertex(r, c);
  215.             score := score + 1;
  216.             if show then begin { redraw the whole board }
  217.                 DrawBoard;
  218.             end
  219.             else begin { calculate the moves }
  220.                 ShowMoves;
  221.             end;
  222.         end;
  223.     end;
  224.  
  225.     procedure GameObject.DLine (start: Point; dir: integer);
  226.     begin
  227.         if dir <> -1 then begin
  228.             MoveTo(start.h, start.v);
  229.             Line(diff * (len - 1) * dc[dir], diff * (len - 1) * dr[dir]);
  230.         end;
  231.     end;
  232.  
  233.     procedure GameObject.ShowMoves;
  234.         var
  235.             start, org: Point;
  236.             r, c, i, cnt: integer;
  237.             ps: penState;
  238.             title: str255;
  239.  
  240.         function RandomChance (n: integer): boolean;
  241.         begin
  242.             if n <= 1 then begin
  243.                 RandomChance := true;
  244.             end
  245.             else begin
  246.                 RandomChance := (Band(Random, $7FFF) mod n) = 0;
  247.             end;
  248.         end;
  249.         procedure TestDirection (i: integer);
  250.         begin
  251.             if (vertex[r, c] | vertex[r + dr[i], c + dc[i]]) & ValidLine(r, c, i) then begin
  252.                 if show then begin
  253.                     DLine(start, i);
  254.                 end;
  255.                 cnt := cnt + 1;
  256.                 if RandomChance(cnt) then begin
  257.                     mover := r;
  258.                     movec := c;
  259.                     moved := i;
  260.                 end;
  261.             end;
  262.         end;
  263.  
  264.     begin
  265.         SetPort(window);
  266.         GetPenState(ps);
  267.         PenPat(ltgray);
  268.         cnt := 0;
  269.         for r := 1 to max_row do begin
  270.             for c := 1 to max_col do begin
  271.                 CellToPoint(r, c, start);
  272.                 if (r >= len) & (c <= max_col - len + 1) then begin
  273.                     TestDirection(1);
  274.                 end;
  275.                 if (c <= max_col - len + 1) then begin
  276.                     TestDirection(2);
  277.                 end;
  278.                 if (r <= max_row - len + 1) & (c <= max_col - len + 1) then begin
  279.                     TestDirection(3);
  280.                 end;
  281.                 if (r <= max_row - len + 1) then begin
  282.                     TestDirection(4);
  283.                 end;
  284.  
  285.             end;
  286.         end;
  287.         SetPenState(ps);
  288.         moves := cnt;
  289.         finished := moves = 0;
  290.         if show or true then begin
  291.             title := StringOf('Score: ', score : 1, ' Moves: ', moves : 1);
  292.         end
  293.         else begin
  294.             title := StringOf('Score: ', score : 1);
  295.         end;
  296.         if finished then begin
  297.             title := concat('(', title, ')');
  298.         end;
  299.         SetWindowTitle(window, title);
  300.     end;
  301.  
  302.     procedure GameObject.DoMove (pt: Point);
  303.         var
  304.             start: Point;
  305.             goods: array[0..7] of boolean;
  306.             fin: Point;
  307.             r, c, d, i, cnt, mini, oldmini: integer;
  308.             dist, mindist: longInt;
  309.             ps: penState;
  310.     begin
  311.         if PointToCell(pt, r, c) then begin
  312.             cnt := 0;
  313.             for i := 0 to 7 do begin
  314.                 goods[i] := ValidLine(r, c, i);
  315.                 cnt := cnt + ord(goods[i]);
  316.             end;
  317.             CellToPoint(r, c, start);
  318.             GetPenState(ps);
  319.             PenMode(patXor);
  320.             PenPat(dkgray);
  321.             oldmini := -1;
  322.             while Button do begin
  323.                 GetMouse(pt);
  324.                 mini := -1;
  325.                 mindist := maxInt;
  326.                 fin.h := start.h - pt.h;
  327.                 fin.v := start.v - pt.v;
  328.                 dist := longint(fin.h) * fin.h + longInt(fin.v) * fin.v;
  329.                 if dist < longInt(len) * len * diff * diff * 3 div 2 then begin
  330.                     for i := 0 to 7 do begin
  331.                         if goods[i] then begin
  332.                             fin.h := pt.h - (start.h + dc[i] * diff * len * (3 - ord(odd(i))) div 3);
  333.                             fin.v := pt.v - (start.v + dr[i] * diff * len * (3 - ord(odd(i))) div 3);
  334.                             dist := longInt(fin.h) * fin.h + longInt(fin.v) * fin.v;
  335.                             if dist < mindist then begin
  336.                                 mindist := dist;
  337.                                 mini := i;
  338.                             end;
  339.                         end;
  340.                     end;
  341.                 end;
  342.                 if (oldmini <> mini) then begin
  343.                     DLine(start, oldmini);
  344.                     DLine(start, mini);
  345.                     oldmini := mini;
  346.                 end;
  347.             end;
  348.             DLine(start, oldmini);
  349.             SetPenState(ps);
  350.             if oldmini <> -1 then begin
  351.                 d := oldmini;
  352.                 repeat
  353.                     DoLine(r, c, d);
  354.                     r := mover;
  355.                     c := movec;
  356.                     d := moved;
  357.                 until not auto or (moves <> 1);
  358.             end;
  359.         end;
  360.     end;
  361.  
  362.     procedure gameObject.DoItemWhere (er: eventRecord; item: integer);
  363.     begin
  364.         case item of
  365.             1:  begin
  366.                 SetPort(window);
  367.                 GlobalToLocal(er.where);
  368.                 if moves > 0 then begin
  369.                     DoMove(er.where);
  370.                     if moves = 0 then begin
  371.                         if SpeechAvailable then begin
  372.                             Speak(128, 6);
  373.                         end;
  374.                     end;
  375.                 end;
  376.             end;
  377.             otherwise
  378.                 ;
  379.         end;
  380.     end;
  381.  
  382.     procedure DrawProc (dlg: DialogPtr; item: integer);
  383.     begin
  384.         GameObject(GetWObject(dlg)).DrawBoard;
  385.     end;
  386.  
  387.     procedure NewGame;
  388.         var
  389.             obj: GameObject;
  390.     begin
  391.         new(obj);
  392.         obj.Create(200);
  393.         obj.show := false;
  394.         obj.auto := true;
  395.         SetDItemHandle(obj.window, 1, @DrawProc);
  396.         ShowWindow(obj.window);
  397.     end;
  398.  
  399.     procedure SetNewGameMenu (themenu, theitem: integer);
  400.         var
  401.             t, c: longInt;
  402.     begin
  403.         PurgeSpace(t, c);
  404.         SetIDItemEnable(themenu, theitem, c > 25000);
  405.     end;
  406.  
  407.     function GetGameObject: GameObject;
  408.         var
  409.             can: boolean;
  410.             obj: WObject;
  411.     begin
  412.         obj := nil;
  413.         if FrontWindow <> nil then begin
  414.             obj := GetWObject(FrontWindow);
  415.             if not member(obj, GameObject) | GameObject(obj).finished then begin
  416.                 obj := nil;
  417.             end;
  418.         end;
  419.         GetGameObject := GameObject(obj);
  420.     end;
  421.  
  422.     procedure ToggleAutoMove;
  423.         var
  424.             obj: GameObject;
  425.     begin
  426.         obj := GameObject(GetWObject(FrontWindow));
  427.         obj.auto := not obj.auto;
  428.     end;
  429.  
  430.     procedure SetToggleAutoMoveMenu (themenu, theitem: integer);
  431.         var
  432.             obj: GameObject;
  433.     begin
  434.         obj := GetGameObject;
  435.         SetIDItemEnable(themenu, theitem, obj <> nil);
  436.         SetItemMark(GetMHandle(themenu), theitem, chr($12 * ord((obj <> nil) & obj.auto)));
  437.     end;
  438.  
  439.     procedure ToggleShowMoves;
  440.         var
  441.             obj: GameObject;
  442.             r: rect;
  443.     begin
  444.         obj := GetGameObject;
  445.         obj.show := not obj.show;
  446.         if obj.show then begin
  447.             obj.ShowMoves;
  448.         end
  449.         else begin
  450.             obj.DrawBoard;
  451.         end;
  452.     end;
  453.  
  454.     procedure SetToggleShowMovesMenu (themenu, theitem: integer);
  455.         var
  456.             obj: GameObject;
  457.     begin
  458.         obj := GetGameObject;
  459.         SetIDItemEnable(themenu, theitem, obj <> nil);
  460.         SetItemMark(GetMHandle(themenu), theitem, chr($12 * ord((obj <> nil) & obj.show)));
  461.     end;
  462.  
  463.     procedure DoBestMove;
  464.         var
  465.             obj: GameObject;
  466.     begin
  467.         obj := GetGameObject;
  468.         obj.DoLine(obj.mover, obj.movec, obj.moved);
  469.     end;
  470.  
  471.     procedure DoLotsOfMoves;
  472.         var
  473.             obj: GameObject;
  474.             er: EventRecord;
  475.             dummy: boolean;
  476.     begin
  477.         obj := GetGameObject;
  478.         while (obj.moves > 0) & not Button do begin
  479.             obj.DoLine(obj.mover, obj.movec, obj.moved);
  480.         end;
  481.     end;
  482.  
  483.     procedure SetDoBestMenu (themenu, theitem: integer);
  484.     begin
  485.         SetIDItemEnable(themenu, theitem, GetGameObject <> nil);
  486.     end;
  487.  
  488. {$S Init}
  489.     procedure InitGame;
  490.     begin
  491.         SetFBoth('game', @NewGame, @SetNewGameMenu);
  492.         SetFBoth('auto', @ToggleAutoMove, @SetToggleAutoMoveMenu);
  493.         SetFBoth('show', @ToggleShowMoves, @SetToggleShowMovesMenu);
  494.         SetFBoth('best', @DoBestMove, @SetDoBestMenu);
  495.         SetFBoth('lots', @DoLotsOfMoves, @SetDoBestMenu);
  496.         dr[0] := -1;
  497.         dr[1] := -1;
  498.         dr[2] := 0;
  499.         dr[3] := 1;
  500.         dr[4] := 1;
  501.         dr[5] := 1;
  502.         dr[6] := 0;
  503.         dr[7] := -1;
  504.         dc[0] := 0;
  505.         dc[1] := 1;
  506.         dc[2] := 1;
  507.         dc[3] := 1;
  508.         dc[4] := 0;
  509.         dc[5] := -1;
  510.         dc[6] := -1;
  511.         dc[7] := -1;
  512.     end;
  513.  
  514. {$S Term}
  515.     procedure FinishGame;
  516.     begin
  517.     end;
  518.  
  519. end.